home *** CD-ROM | disk | FTP | other *** search
/ The X-Philes (2nd Revision) / The X-Philes Number 1 (1995).iso / xphiles / hp48hor2 / basecalc.src < prev    next >
Text File  |  1993-02-18  |  3KB  |  99 lines
  1. %%HP: T(3)A(R)F(.);
  2. @ BASECALC by Ian Matthew Smith
  3. @ Automatic decimal lengths added by Joe Horn
  4. DIR
  5.   BMTH @ create custom menu
  6.     \<< { Add \<< IB2\-> + \->IB \>> }
  7.         { Sub \<< IB2\-> - \->IB \>> }
  8.         { Mul \<< IB2\-> * \->IB \>> }
  9.         { Div \<< IB2\-> / \->IB \>> }
  10.       BBASE "/" IBFIX + +
  11.       { \<< B\->FIX 'BBASE' STO BMTH \>>
  12.         \<< B\->FIX SWAP IB\-> SWAP 'BBASE' STO \->IB BMTH \>>
  13.         \<< 'IBFIX' STO BMTH \>> }
  14.       2 \->LIST { CONV {
  15.       \<< DUP
  16.         IF TYPE 2 ==
  17.         THEN IB\->
  18.         ELSE \->IB
  19.         END
  20.       \>>
  21.       \<< DUP
  22.         IF TYPE 0 ==
  23.         THEN R\->B
  24.         ELSE DUP
  25.           IF TYPE 10 ==
  26.           THEN B\->R
  27.           END
  28.         END
  29.       \>> } } 6 \->LIST TMENU
  30.     \>>
  31.   \->IB
  32.     \<< DUP
  33.       IF TYPE 0 ==
  34.       THEN DUP FP SWAP IP R\->B
  35.       ELSE 0 SWAP
  36.       END DUP
  37.       IF TYPE 10 ==
  38.       THEN RCWS SWAP "" SWAP 64 STWS
  39.         WHILE DUP B\->R
  40.         REPEAT DUP BBASE DUP2 / * - 1 + BSTR SWAP
  41.           B\->R DUP SUB ROT + SWAP BBASE /
  42.         END DROP SWAP STWS SWAP
  43.         IF DUP BBASE IBFIX ^ * 1 <
  44.         THEN DROP
  45.         ELSE "" SWAP 1 IBFIX
  46.           START
  47.             IF DUP 0 \=/
  48.             THEN BBASE * DUP IP BSTR SWAP 1 + DUP SUB ROT SWAP + SWAP FP
  49.             END
  50.           NEXT DROP "." SWAP + +
  51.         END
  52.       END
  53.     \>>
  54.   IB\->
  55.     \<< DUP
  56.       IF TYPE 2 ==
  57.       THEN RCWS SWAP 64 STWS
  58.         IF DUP "." POS
  59.         THEN DUP DUP "." POS SWAP DUP SIZE ROT 1 + SWAP SUB
  60.           SWAP DUP "." POS 1 - 1 SWAP SUB
  61.         ELSE "" SWAP
  62.         END # 0d SWAP DUP SIZE 1 - 0 SWAP
  63.         FOR j DUP DUP SIZE j - DUP SUB BSTR SWAP POS 1 - # 1d
  64.           IF j 0 >
  65.           THEN BBASE 1 j
  66.             START DUP ROT * SWAP
  67.             NEXT DROP
  68.           END * ROT + SWAP
  69.         NEXT DROP
  70.         IF DUP B\->R 1.E12 < IBFIX AND
  71.         THEN B\->R
  72.         END SWAP
  73.         IF DUP SIZE
  74.         THEN 0 SWAP DUP SIZE 1 SWAP
  75.           FOR j DUP j j SUB BSTR SWAP POS 1 - BBASE j NEG ^ * ROT + SWAP
  76.           NEXT DROP +
  77.         ELSE DROP
  78.         END SWAP STWS
  79.       ELSE
  80.         IF DUP TYPE 0 == IBFIX NOT AND
  81.         THEN R\->B
  82.         END
  83.       END
  84.     \>>
  85.   IB2\->
  86.     \<< IB\-> SWAP IB\-> SWAP
  87.     \>>
  88.   BBASE 16
  89.   IBFIX 0
  90.   \->IB2
  91.     \<< \->IB SWAP \->IB SWAP
  92.     \>>
  93.   B\->FIX  @ this tiny routine was tacked on by Joe Horn
  94.     \<< 2 MAX 62 MIN 12 OVER LOG / IP 'IBFIX' STO
  95.     \>>
  96.   BSTR
  97. "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
  98. END
  99.